{-# LANGUAGE TypeFamilies               #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Lirio.Percussion
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  GHC
--
-- Percussion notation.
--
--------------------------------------------------------------------------------


module Lirio.Percussion
  (
  

  -- * Percussion defs
    NoteList
  , notelist

  , DrumPitch
  , drumPitch

  ) where

import qualified Lirio.Base.RelDuration as RD
import Lirio.Base.Overloading
import Lirio.Score hiding ( text )

import Text.PrettyPrint.Leijen hiding ( dot )   -- package: wl-pprint

import Control.Applicative hiding ( empty )
import Data.Monoid hiding ( (<>) )

-- Should NoteList have an ust?
--
newtype NoteList a = NoteList { getNoteList :: RD.DRelative () a }



instance Functor NoteList where
  fmap f = NoteList . fmap f . getNoteList


instance Applicative NoteList where
  pure a    = NoteList $ pure  a
  mf <*> ma = NoteList $ getNoteList mf <*> getNoteList ma


instance Monad NoteList where
  return   = pure
  ma >>= k = NoteList $ getNoteList ma >>= getNoteList . k 
                                  

instance Monoid a => Monoid (NoteList a) where
  mempty = pure mempty
  ma `mappend` mb = NoteList $ getNoteList ma `mappend` getNoteList mb


-- | NoteLists are /run/ within a Score.
--
notelist :: NoteList a -> Score  a
notelist ma = withScore $ \_ -> 
    let (a,_,w) = RD.runNotelist () (getNoteList ma) in (a,w)
    
 


newtype DrumPitch = DrumPitch { getDrumPitch :: String }

-- | Exported constructor for drum pitches.
--
drumPitch :: String -> DrumPitch
drumPitch = DrumPitch


--------------------------------------------------------------------------------
-- Overloading instances

instance HasNewlineM NoteList where
  newline = NoteList newline

instance HasCommandM NoteList where
  command = NoteList . command

instance NoteListM NoteList

instance GenericMarkM NoteList where
  genericMark = NoteList . genericMark


instance GenericEventM NoteList where
  genericEvent doc d = NoteList $ genericEvent doc d




instance HasRestM NoteList
instance HasSpacerM NoteList


type instance Pch NoteList = DrumPitch

instance NoteM NoteList where
  note p = NoteList . genericEvent (text $ getDrumPitch p)

instance ChordM NoteList where
  chord ps = NoteList . genericEvent (angles $ hsep $ map fn ps)
    where
      fn = text . getDrumPitch

instance GroupingM NoteList where
  prefix d = NoteList . prefix d . getNoteList 
  suffix d = NoteList . suffix d . getNoteList

